home *** CD-ROM | disk | FTP | other *** search
/ PC World Komputer 2010 April / PCWorld0410.iso / hity wydania / Ubuntu 9.10 PL / karmelkowy-koliberek-desktop-9.10-i386-PL.iso / casper / filesystem.squashfs / usr / share / perl / 5.10.0 / open.pm < prev    next >
Text File  |  2009-10-01  |  8KB  |  259 lines
  1. package open;
  2. use warnings;
  3.  
  4. our $VERSION = '1.06';
  5.  
  6. require 5.008001; # for PerlIO::get_layers()
  7.  
  8. my $locale_encoding;
  9.  
  10. sub _get_encname {
  11.     return ($1, Encode::resolve_alias($1)) if $_[0] =~ /^:?encoding\((.+)\)$/;
  12.     return;
  13. }
  14.  
  15. sub croak {
  16.     require Carp; goto &Carp::croak;
  17. }
  18.  
  19. sub _drop_oldenc {
  20.     # If by the time we arrive here there already is at the top of the
  21.     # perlio layer stack an encoding identical to what we would like
  22.     # to push via this open pragma, we will pop away the old encoding
  23.     # (+utf8) so that we can push ourselves in place (this is easier
  24.     # than ignoring pushing ourselves because of the way how ${^OPEN}
  25.     # works).  So we are looking for something like
  26.     #
  27.     #   stdio encoding(xxx) utf8
  28.     #
  29.     # in the existing layer stack, and in the new stack chunk for
  30.     #
  31.     #   :encoding(xxx)
  32.     #
  33.     # If we find a match, we pop the old stack (once, since
  34.     # the utf8 is just a flag on the encoding layer)
  35.     my ($h, @new) = @_;
  36.     return unless @new >= 1 && $new[-1] =~ /^:encoding\(.+\)$/;
  37.     my @old = PerlIO::get_layers($h);
  38.     return unless @old >= 3 &&
  39.               $old[-1] eq 'utf8' &&
  40.                   $old[-2] =~ /^encoding\(.+\)$/;
  41.     require Encode;
  42.     my ($loname, $lcname) = _get_encname($old[-2]);
  43.     unless (defined $lcname) { # Should we trust get_layers()?
  44.     croak("open: Unknown encoding '$loname'");
  45.     }
  46.     my ($voname, $vcname) = _get_encname($new[-1]);
  47.     unless (defined $vcname) {
  48.     croak("open: Unknown encoding '$voname'");
  49.     }
  50.     if ($lcname eq $vcname) {
  51.     binmode($h, ":pop"); # utf8 is part of the encoding layer
  52.     }
  53. }
  54.  
  55. sub import {
  56.     my ($class,@args) = @_;
  57.     croak("open: needs explicit list of PerlIO layers") unless @args;
  58.     my $std;
  59.     my ($in,$out) = split(/\0/,(${^OPEN} || "\0"), -1);
  60.     while (@args) {
  61.     my $type = shift(@args);
  62.     my $dscp;
  63.     if ($type =~ /^:?(utf8|locale|encoding\(.+\))$/) {
  64.         $type = 'IO';
  65.         $dscp = ":$1";
  66.     } elsif ($type eq ':std') {
  67.         $std = 1;
  68.         next;
  69.     } else {
  70.         $dscp = shift(@args) || '';
  71.     }
  72.     my @val;
  73.     foreach my $layer (split(/\s+/,$dscp)) {
  74.             $layer =~ s/^://;
  75.         if ($layer eq 'locale') {
  76.         require Encode;
  77.         require encoding;
  78.         $locale_encoding = encoding::_get_locale_encoding()
  79.             unless defined $locale_encoding;
  80.         (warnings::warnif("layer", "Cannot figure out an encoding to use"), last)
  81.             unless defined $locale_encoding;
  82.                 $layer = "encoding($locale_encoding)";
  83.         $std = 1;
  84.         } else {
  85.         my $target = $layer;        # the layer name itself
  86.         $target =~ s/^(\w+)\(.+\)$/$1/;    # strip parameters
  87.  
  88.         unless(PerlIO::Layer::->find($target,1)) {
  89.             warnings::warnif("layer", "Unknown PerlIO layer '$target'");
  90.         }
  91.         }
  92.         push(@val,":$layer");
  93.         if ($layer =~ /^(crlf|raw)$/) {
  94.         $^H{"open_$type"} = $layer;
  95.         }
  96.     }
  97.     if ($type eq 'IN') {
  98.         _drop_oldenc(*STDIN, @val);
  99.         $in  = join(' ', @val);
  100.     }
  101.     elsif ($type eq 'OUT') {
  102.         _drop_oldenc(*STDOUT, @val);
  103.         $out = join(' ', @val);
  104.     }
  105.     elsif ($type eq 'IO') {
  106.         _drop_oldenc(*STDIN,  @val);
  107.         _drop_oldenc(*STDOUT, @val);
  108.         $in = $out = join(' ', @val);
  109.     }
  110.     else {
  111.         croak "Unknown PerlIO layer class '$type'";
  112.     }
  113.     }
  114.     ${^OPEN} = join("\0", $in, $out);
  115.     if ($std) {
  116.     if ($in) {
  117.         if ($in =~ /:utf8\b/) {
  118.             binmode(STDIN,  ":utf8");
  119.         } elsif ($in =~ /(\w+\(.+\))/) {
  120.             binmode(STDIN,  ":$1");
  121.         }
  122.     }
  123.     if ($out) {
  124.         if ($out =~ /:utf8\b/) {
  125.         binmode(STDOUT,  ":utf8");
  126.         binmode(STDERR,  ":utf8");
  127.         } elsif ($out =~ /(\w+\(.+\))/) {
  128.         binmode(STDOUT,  ":$1");
  129.         binmode(STDERR,  ":$1");
  130.         }
  131.     }
  132.     }
  133. }
  134.  
  135. 1;
  136. __END__
  137.  
  138. =head1 NAME
  139.  
  140. open - perl pragma to set default PerlIO layers for input and output
  141.  
  142. =head1 SYNOPSIS
  143.  
  144.     use open IN  => ":crlf", OUT => ":bytes";
  145.     use open OUT => ':utf8';
  146.     use open IO  => ":encoding(iso-8859-7)";
  147.  
  148.     use open IO  => ':locale';
  149.  
  150.     use open ':encoding(utf8)';
  151.     use open ':locale';
  152.     use open ':encoding(iso-8859-7)';
  153.  
  154.     use open ':std';
  155.  
  156. =head1 DESCRIPTION
  157.  
  158. Full-fledged support for I/O layers is now implemented provided
  159. Perl is configured to use PerlIO as its IO system (which is now the
  160. default).
  161.  
  162. The C<open> pragma serves as one of the interfaces to declare default
  163. "layers" (also known as "disciplines") for all I/O. Any two-argument
  164. open(), readpipe() (aka qx//) and similar operators found within the
  165. lexical scope of this pragma will use the declared defaults.
  166. Even three-argument opens may be affected by this pragma
  167. when they don't specify IO layers in MODE.
  168.  
  169. With the C<IN> subpragma you can declare the default layers
  170. of input streams, and with the C<OUT> subpragma you can declare
  171. the default layers of output streams.  With the C<IO>  subpragma
  172. you can control both input and output streams simultaneously.
  173.  
  174. If you have a legacy encoding, you can use the C<:encoding(...)> tag.
  175.  
  176. If you want to set your encoding layers based on your
  177. locale environment variables, you can use the C<:locale> tag.
  178. For example:
  179.  
  180.     $ENV{LANG} = 'ru_RU.KOI8-R';
  181.     # the :locale will probe the locale environment variables like LANG
  182.     use open OUT => ':locale';
  183.     open(O, ">koi8");
  184.     print O chr(0x430); # Unicode CYRILLIC SMALL LETTER A = KOI8-R 0xc1
  185.     close O;
  186.     open(I, "<koi8");
  187.     printf "%#x\n", ord(<I>), "\n"; # this should print 0xc1
  188.     close I;
  189.  
  190. These are equivalent
  191.  
  192.     use open ':encoding(utf8)';
  193.     use open IO => ':encoding(utf8)';
  194.  
  195. as are these
  196.  
  197.     use open ':locale';
  198.     use open IO => ':locale';
  199.  
  200. and these
  201.  
  202.     use open ':encoding(iso-8859-7)';
  203.     use open IO => ':encoding(iso-8859-7)';
  204.  
  205. The matching of encoding names is loose: case does not matter, and
  206. many encodings have several aliases.  See L<Encode::Supported> for
  207. details and the list of supported locales.
  208.  
  209. When open() is given an explicit list of layers (with the three-arg
  210. syntax), they override the list declared using this pragma.
  211.  
  212. The C<:std> subpragma on its own has no effect, but if combined with
  213. the C<:utf8> or C<:encoding> subpragmas, it converts the standard
  214. filehandles (STDIN, STDOUT, STDERR) to comply with encoding selected
  215. for input/output handles.  For example, if both input and out are
  216. chosen to be C<:encoding(utf8)>, a C<:std> will mean that STDIN, STDOUT,
  217. and STDERR are also in C<:encoding(utf8)>.  On the other hand, if only
  218. output is chosen to be in C<< :encoding(koi8r) >>, a C<:std> will cause
  219. only the STDOUT and STDERR to be in C<koi8r>.  The C<:locale> subpragma
  220. implicitly turns on C<:std>.
  221.  
  222. The logic of C<:locale> is described in full in L<encoding>,
  223. but in short it is first trying nl_langinfo(CODESET) and then
  224. guessing from the LC_ALL and LANG locale environment variables.
  225.  
  226. Directory handles may also support PerlIO layers in the future.
  227.  
  228. =head1 NONPERLIO FUNCTIONALITY
  229.  
  230. If Perl is not built to use PerlIO as its IO system then only the two
  231. pseudo-layers C<:bytes> and C<:crlf> are available.
  232.  
  233. The C<:bytes> layer corresponds to "binary mode" and the C<:crlf>
  234. layer corresponds to "text mode" on platforms that distinguish
  235. between the two modes when opening files (which is many DOS-like
  236. platforms, including Windows).  These two layers are no-ops on
  237. platforms where binmode() is a no-op, but perform their functions
  238. everywhere if PerlIO is enabled.
  239.  
  240. =head1 IMPLEMENTATION DETAILS
  241.  
  242. There is a class method in C<PerlIO::Layer> C<find> which is
  243. implemented as XS code.  It is called by C<import> to validate the
  244. layers:
  245.  
  246.    PerlIO::Layer::->find("perlio")
  247.  
  248. The return value (if defined) is a Perl object, of class
  249. C<PerlIO::Layer> which is created by the C code in F<perlio.c>.  As
  250. yet there is nothing useful you can do with the object at the perl
  251. level.
  252.  
  253. =head1 SEE ALSO
  254.  
  255. L<perlfunc/"binmode">, L<perlfunc/"open">, L<perlunicode>, L<PerlIO>,
  256. L<encoding>
  257.  
  258. =cut
  259.